home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tcl7.4 / tclCmdAH.c < prev    next >
C/C++ Source or Header  |  1995-05-05  |  23KB  |  945 lines
  1. /* 
  2.  * tclCmdAH.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    A to H.
  7.  *
  8.  * Copyright (c) 1987-1993 The Regents of the University of California.
  9.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  */
  14.  
  15. static char sccsid[] = "@(#) tclCmdAH.c 1.98 95/05/05 09:29:51";
  16.  
  17. #include "tclInt.h"
  18. #include "tclPort.h"
  19.  
  20. /*
  21.  *----------------------------------------------------------------------
  22.  *
  23.  * Tcl_BreakCmd --
  24.  *
  25.  *    This procedure is invoked to process the "break" Tcl command.
  26.  *    See the user documentation for details on what it does.
  27.  *
  28.  * Results:
  29.  *    A standard Tcl result.
  30.  *
  31.  * Side effects:
  32.  *    See the user documentation.
  33.  *
  34.  *----------------------------------------------------------------------
  35.  */
  36.  
  37.     /* ARGSUSED */
  38. int
  39. Tcl_BreakCmd(dummy, interp, argc, argv)
  40.     ClientData dummy;            /* Not used. */
  41.     Tcl_Interp *interp;            /* Current interpreter. */
  42.     int argc;                /* Number of arguments. */
  43.     char **argv;            /* Argument strings. */
  44. {
  45.     if (argc != 1) {
  46.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  47.         argv[0], "\"", (char *) NULL);
  48.     return TCL_ERROR;
  49.     }
  50.     return TCL_BREAK;
  51. }
  52.  
  53. /*
  54.  *----------------------------------------------------------------------
  55.  *
  56.  * Tcl_CaseCmd --
  57.  *
  58.  *    This procedure is invoked to process the "case" Tcl command.
  59.  *    See the user documentation for details on what it does.
  60.  *
  61.  * Results:
  62.  *    A standard Tcl result.
  63.  *
  64.  * Side effects:
  65.  *    See the user documentation.
  66.  *
  67.  *----------------------------------------------------------------------
  68.  */
  69.  
  70.     /* ARGSUSED */
  71. int
  72. Tcl_CaseCmd(dummy, interp, argc, argv)
  73.     ClientData dummy;            /* Not used. */
  74.     Tcl_Interp *interp;            /* Current interpreter. */
  75.     int argc;                /* Number of arguments. */
  76.     char **argv;            /* Argument strings. */
  77. {
  78.     int i, result;
  79.     int body;
  80.     char *string;
  81.     int caseArgc, splitArgs;
  82.     char **caseArgv;
  83.  
  84.     if (argc < 3) {
  85.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  86.         argv[0], " string ?in? patList body ... ?default body?\"",
  87.         (char *) NULL);
  88.     return TCL_ERROR;
  89.     }
  90.     string = argv[1];
  91.     body = -1;
  92.     if (strcmp(argv[2], "in") == 0) {
  93.     i = 3;
  94.     } else {
  95.     i = 2;
  96.     }
  97.     caseArgc = argc - i;
  98.     caseArgv = argv + i;
  99.  
  100.     /*
  101.      * If all of the pattern/command pairs are lumped into a single
  102.      * argument, split them out again.
  103.      */
  104.  
  105.     splitArgs = 0;
  106.     if (caseArgc == 1) {
  107.     result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
  108.     if (result != TCL_OK) {
  109.         return result;
  110.     }
  111.     splitArgs = 1;
  112.     }
  113.  
  114.     for (i = 0; i < caseArgc; i += 2) {
  115.     int patArgc, j;
  116.     char **patArgv;
  117.     register char *p;
  118.  
  119.     if (i == (caseArgc-1)) {
  120.         interp->result = "extra case pattern with no body";
  121.         result = TCL_ERROR;
  122.         goto cleanup;
  123.     }
  124.  
  125.     /*
  126.      * Check for special case of single pattern (no list) with
  127.      * no backslash sequences.
  128.      */
  129.  
  130.     for (p = caseArgv[i]; *p != 0; p++) {
  131.         if (isspace(UCHAR(*p)) || (*p == '\\')) {
  132.         break;
  133.         }
  134.     }
  135.     if (*p == 0) {
  136.         if ((*caseArgv[i] == 'd')
  137.             && (strcmp(caseArgv[i], "default") == 0)) {
  138.         body = i+1;
  139.         }
  140.         if (Tcl_StringMatch(string, caseArgv[i])) {
  141.         body = i+1;
  142.         goto match;
  143.         }
  144.         continue;
  145.     }
  146.  
  147.     /*
  148.      * Break up pattern lists, then check each of the patterns
  149.      * in the list.
  150.      */
  151.  
  152.     result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
  153.     if (result != TCL_OK) {
  154.         goto cleanup;
  155.     }
  156.     for (j = 0; j < patArgc; j++) {
  157.         if (Tcl_StringMatch(string, patArgv[j])) {
  158.         body = i+1;
  159.         break;
  160.         }
  161.     }
  162.     ckfree((char *) patArgv);
  163.     if (j < patArgc) {
  164.         break;
  165.     }
  166.     }
  167.  
  168.     match:
  169.     if (body != -1) {
  170.     result = Tcl_Eval(interp, caseArgv[body]);
  171.     if (result == TCL_ERROR) {
  172.         char msg[100];
  173.         sprintf(msg, "\n    (\"%.50s\" arm line %d)", caseArgv[body-1],
  174.             interp->errorLine);
  175.         Tcl_AddErrorInfo(interp, msg);
  176.     }
  177.     goto cleanup;
  178.     }
  179.  
  180.     /*
  181.      * Nothing matched:  return nothing.
  182.      */
  183.  
  184.     result = TCL_OK;
  185.  
  186.     cleanup:
  187.     if (splitArgs) {
  188.     ckfree((char *) caseArgv);
  189.     }
  190.     return result;
  191. }
  192.  
  193. /*
  194.  *----------------------------------------------------------------------
  195.  *
  196.  * Tcl_CatchCmd --
  197.  *
  198.  *    This procedure is invoked to process the "catch" Tcl command.
  199.  *    See the user documentation for details on what it does.
  200.  *
  201.  * Results:
  202.  *    A standard Tcl result.
  203.  *
  204.  * Side effects:
  205.  *    See the user documentation.
  206.  *
  207.  *----------------------------------------------------------------------
  208.  */
  209.  
  210.     /* ARGSUSED */
  211. int
  212. Tcl_CatchCmd(dummy, interp, argc, argv)
  213.     ClientData dummy;            /* Not used. */
  214.     Tcl_Interp *interp;            /* Current interpreter. */
  215.     int argc;                /* Number of arguments. */
  216.     char **argv;            /* Argument strings. */
  217. {
  218.     int result;
  219.  
  220.     if ((argc != 2) && (argc != 3)) {
  221.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  222.         argv[0], " command ?varName?\"", (char *) NULL);
  223.     return TCL_ERROR;
  224.     }
  225.     result = Tcl_Eval(interp, argv[1]);
  226.     if (argc == 3) {
  227.     if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
  228.         Tcl_SetResult(interp, "couldn't save command result in variable",
  229.             TCL_STATIC);
  230.         return TCL_ERROR;
  231.     }
  232.     }
  233.     Tcl_ResetResult(interp);
  234.     sprintf(interp->result, "%d", result);
  235.     return TCL_OK;
  236. }
  237.  
  238. /*
  239.  *----------------------------------------------------------------------
  240.  *
  241.  * Tcl_ConcatCmd --
  242.  *
  243.  *    This procedure is invoked to process the "concat" Tcl command.
  244.  *    See the user documentation for details on what it does.
  245.  *
  246.  * Results:
  247.  *    A standard Tcl result.
  248.  *
  249.  * Side effects:
  250.  *    See the user documentation.
  251.  *
  252.  *----------------------------------------------------------------------
  253.  */
  254.  
  255.     /* ARGSUSED */
  256. int
  257. Tcl_ConcatCmd(dummy, interp, argc, argv)
  258.     ClientData dummy;            /* Not used. */
  259.     Tcl_Interp *interp;            /* Current interpreter. */
  260.     int argc;                /* Number of arguments. */
  261.     char **argv;            /* Argument strings. */
  262. {
  263.     if (argc >= 2) {
  264.     interp->result = Tcl_Concat(argc-1, argv+1);
  265.     interp->freeProc = (Tcl_FreeProc *) free;
  266.     }
  267.     return TCL_OK;
  268. }
  269.  
  270. /*
  271.  *----------------------------------------------------------------------
  272.  *
  273.  * Tcl_ContinueCmd --
  274.  *
  275.  *    This procedure is invoked to process the "continue" Tcl command.
  276.  *    See the user documentation for details on what it does.
  277.  *
  278.  * Results:
  279.  *    A standard Tcl result.
  280.  *
  281.  * Side effects:
  282.  *    See the user documentation.
  283.  *
  284.  *----------------------------------------------------------------------
  285.  */
  286.  
  287.     /* ARGSUSED */
  288. int
  289. Tcl_ContinueCmd(dummy, interp, argc, argv)
  290.     ClientData dummy;            /* Not used. */
  291.     Tcl_Interp *interp;            /* Current interpreter. */
  292.     int argc;                /* Number of arguments. */
  293.     char **argv;            /* Argument strings. */
  294. {
  295.     if (argc != 1) {
  296.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  297.         "\"", (char *) NULL);
  298.     return TCL_ERROR;
  299.     }
  300.     return TCL_CONTINUE;
  301. }
  302.  
  303. /*
  304.  *----------------------------------------------------------------------
  305.  *
  306.  * Tcl_ErrorCmd --
  307.  *
  308.  *    This procedure is invoked to process the "error" Tcl command.
  309.  *    See the user documentation for details on what it does.
  310.  *
  311.  * Results:
  312.  *    A standard Tcl result.
  313.  *
  314.  * Side effects:
  315.  *    See the user documentation.
  316.  *
  317.  *----------------------------------------------------------------------
  318.  */
  319.  
  320.     /* ARGSUSED */
  321. int
  322. Tcl_ErrorCmd(dummy, interp, argc, argv)
  323.     ClientData dummy;            /* Not used. */
  324.     Tcl_Interp *interp;            /* Current interpreter. */
  325.     int argc;                /* Number of arguments. */
  326.     char **argv;            /* Argument strings. */
  327. {
  328.     Interp *iPtr = (Interp *) interp;
  329.  
  330.     if ((argc < 2) || (argc > 4)) {
  331.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  332.         " message ?errorInfo? ?errorCode?\"", (char *) NULL);
  333.     return TCL_ERROR;
  334.     }
  335.     if ((argc >= 3) && (argv[2][0] != 0)) {
  336.     Tcl_AddErrorInfo(interp, argv[2]);
  337.     iPtr->flags |= ERR_ALREADY_LOGGED;
  338.     }
  339.     if (argc == 4) {
  340.     Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
  341.         TCL_GLOBAL_ONLY);
  342.     iPtr->flags |= ERROR_CODE_SET;
  343.     }
  344.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  345.     return TCL_ERROR;
  346. }
  347.  
  348. /*
  349.  *----------------------------------------------------------------------
  350.  *
  351.  * Tcl_EvalCmd --
  352.  *
  353.  *    This procedure is invoked to process the "eval" Tcl command.
  354.  *    See the user documentation for details on what it does.
  355.  *
  356.  * Results:
  357.  *    A standard Tcl result.
  358.  *
  359.  * Side effects:
  360.  *    See the user documentation.
  361.  *
  362.  *----------------------------------------------------------------------
  363.  */
  364.  
  365.     /* ARGSUSED */
  366. int
  367. Tcl_EvalCmd(dummy, interp, argc, argv)
  368.     ClientData dummy;            /* Not used. */
  369.     Tcl_Interp *interp;            /* Current interpreter. */
  370.     int argc;                /* Number of arguments. */
  371.     char **argv;            /* Argument strings. */
  372. {
  373.     int result;
  374.     char *cmd;
  375.  
  376.     if (argc < 2) {
  377.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  378.         " arg ?arg ...?\"", (char *) NULL);
  379.     return TCL_ERROR;
  380.     }
  381.     if (argc == 2) {
  382.     result = Tcl_Eval(interp, argv[1]);
  383.     } else {
  384.     
  385.     /*
  386.      * More than one argument:  concatenate them together with spaces
  387.      * between, then evaluate the result.
  388.      */
  389.     
  390.     cmd = Tcl_Concat(argc-1, argv+1);
  391.     result = Tcl_Eval(interp, cmd);
  392.     ckfree(cmd);
  393.     }
  394.     if (result == TCL_ERROR) {
  395.     char msg[60];
  396.     sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
  397.     Tcl_AddErrorInfo(interp, msg);
  398.     }
  399.     return result;
  400. }
  401.  
  402. /*
  403.  *----------------------------------------------------------------------
  404.  *
  405.  * Tcl_ExprCmd --
  406.  *
  407.  *    This procedure is invoked to process the "expr" Tcl command.
  408.  *    See the user documentation for details on what it does.
  409.  *
  410.  * Results:
  411.  *    A standard Tcl result.
  412.  *
  413.  * Side effects:
  414.  *    See the user documentation.
  415.  *
  416.  *----------------------------------------------------------------------
  417.  */
  418.  
  419.     /* ARGSUSED */
  420. int
  421. Tcl_ExprCmd(dummy, interp, argc, argv)
  422.     ClientData dummy;            /* Not used. */
  423.     Tcl_Interp *interp;            /* Current interpreter. */
  424.     int argc;                /* Number of arguments. */
  425.     char **argv;            /* Argument strings. */
  426. {
  427.     Tcl_DString buffer;
  428.     int i, result;
  429.  
  430.     if (argc < 2) {
  431.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  432.         " arg ?arg ...?\"", (char *) NULL);
  433.     return TCL_ERROR;
  434.     }
  435.  
  436.     if (argc == 2) {
  437.     return Tcl_ExprString(interp, argv[1]);
  438.     }
  439.     Tcl_DStringInit(&buffer);
  440.     Tcl_DStringAppend(&buffer, argv[1], -1);
  441.     for (i = 2; i < argc; i++) {
  442.     Tcl_DStringAppend(&buffer, " ", 1);
  443.     Tcl_DStringAppend(&buffer, argv[i], -1);
  444.     }
  445.     result = Tcl_ExprString(interp, buffer.string);
  446.     Tcl_DStringFree(&buffer);
  447.     return result;
  448. }
  449.  
  450. /*
  451.  *----------------------------------------------------------------------
  452.  *
  453.  * Tcl_ForCmd --
  454.  *
  455.  *    This procedure is invoked to process the "for" Tcl command.
  456.  *    See the user documentation for details on what it does.
  457.  *
  458.  * Results:
  459.  *    A standard Tcl result.
  460.  *
  461.  * Side effects:
  462.  *    See the user documentation.
  463.  *
  464.  *----------------------------------------------------------------------
  465.  */
  466.  
  467.     /* ARGSUSED */
  468. int
  469. Tcl_ForCmd(dummy, interp, argc, argv)
  470.     ClientData dummy;            /* Not used. */
  471.     Tcl_Interp *interp;            /* Current interpreter. */
  472.     int argc;                /* Number of arguments. */
  473.     char **argv;            /* Argument strings. */
  474. {
  475.     int result, value;
  476.  
  477.     if (argc != 5) {
  478.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  479.         " start test next command\"", (char *) NULL);
  480.     return TCL_ERROR;
  481.     }
  482.  
  483.     result = Tcl_Eval(interp, argv[1]);
  484.     if (result != TCL_OK) {
  485.     if (result == TCL_ERROR) {
  486.         Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
  487.     }
  488.     return result;
  489.     }
  490.     while (1) {
  491.     result = Tcl_ExprBoolean(interp, argv[2], &value);
  492.     if (result != TCL_OK) {
  493.         return result;
  494.     }
  495.     if (!value) {
  496.         break;
  497.     }
  498.     result = Tcl_Eval(interp, argv[4]);
  499.     if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
  500.         if (result == TCL_ERROR) {
  501.         char msg[60];
  502.         sprintf(msg, "\n    (\"for\" body line %d)", interp->errorLine);
  503.         Tcl_AddErrorInfo(interp, msg);
  504.         }
  505.         break;
  506.     }
  507.     result = Tcl_Eval(interp, argv[3]);
  508.     if (result == TCL_BREAK) {
  509.         break;
  510.     } else if (result != TCL_OK) {
  511.         if (result == TCL_ERROR) {
  512.         Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
  513.         }
  514.         return result;
  515.     }
  516.     }
  517.     if (result == TCL_BREAK) {
  518.     result = TCL_OK;
  519.     }
  520.     if (result == TCL_OK) {
  521.     Tcl_ResetResult(interp);
  522.     }
  523.     return result;
  524. }
  525.  
  526. /*
  527.  *----------------------------------------------------------------------
  528.  *
  529.  * Tcl_ForeachCmd --
  530.  *
  531.  *    This procedure is invoked to process the "foreach" Tcl command.
  532.  *    See the user documentation for details on what it does.
  533.  *
  534.  * Results:
  535.  *    A standard Tcl result.
  536.  *
  537.  * Side effects:
  538.  *    See the user documentation.
  539.  *
  540.  *----------------------------------------------------------------------
  541.  */
  542.  
  543.     /* ARGSUSED */
  544. int
  545. Tcl_ForeachCmd(dummy, interp, argc, argv)
  546.     ClientData dummy;            /* Not used. */
  547.     Tcl_Interp *interp;            /* Current interpreter. */
  548.     int argc;                /* Number of arguments. */
  549.     char **argv;            /* Argument strings. */
  550. {
  551.     int listArgc, i, result;
  552.     char **listArgv;
  553.  
  554.     if (argc != 4) {
  555.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  556.         " varName list command\"", (char *) NULL);
  557.     return TCL_ERROR;
  558.     }
  559.  
  560.     /*
  561.      * Break the list up into elements, and execute the command once
  562.      * for each value of the element.
  563.      */
  564.  
  565.     result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
  566.     if (result != TCL_OK) {
  567.     return result;
  568.     }
  569.     for (i = 0; i < listArgc; i++) {
  570.     if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) {
  571.         Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC);
  572.         result = TCL_ERROR;
  573.         break;
  574.     }
  575.  
  576.     result = Tcl_Eval(interp, argv[3]);
  577.     if (result != TCL_OK) {
  578.         if (result == TCL_CONTINUE) {
  579.         result = TCL_OK;
  580.         } else if (result == TCL_BREAK) {
  581.         result = TCL_OK;
  582.         break;
  583.         } else if (result == TCL_ERROR) {
  584.         char msg[100];
  585.         sprintf(msg, "\n    (\"foreach\" body line %d)",
  586.             interp->errorLine);
  587.         Tcl_AddErrorInfo(interp, msg);
  588.         break;
  589.         } else {
  590.         break;
  591.         }
  592.     }
  593.     }
  594.     ckfree((char *) listArgv);
  595.     if (result == TCL_OK) {
  596.     Tcl_ResetResult(interp);
  597.     }
  598.     return result;
  599. }
  600.  
  601. /*
  602.  *----------------------------------------------------------------------
  603.  *
  604.  * Tcl_FormatCmd --
  605.  *
  606.  *    This procedure is invoked to process the "format" Tcl command.
  607.  *    See the user documentation for details on what it does.
  608.  *
  609.  * Results:
  610.  *    A standard Tcl result.
  611.  *
  612.  * Side effects:
  613.  *    See the user documentation.
  614.  *
  615.  *----------------------------------------------------------------------
  616.  */
  617.  
  618.     /* ARGSUSED */
  619. int
  620. Tcl_FormatCmd(dummy, interp, argc, argv)
  621.     ClientData dummy;            /* Not used. */
  622.     Tcl_Interp *interp;            /* Current interpreter. */
  623.     int argc;                /* Number of arguments. */
  624.     char **argv;            /* Argument strings. */
  625. {
  626.     register char *format;    /* Used to read characters from the format
  627.                  * string. */
  628.     char newFormat[40];        /* A new format specifier is generated here. */
  629.     int width;            /* Field width from field specifier, or 0 if
  630.                  * no width given. */
  631.     int precision;        /* Field precision from field specifier, or 0
  632.                  * if no precision given. */
  633.     int size;            /* Number of bytes needed for result of
  634.                  * conversion, based on type of conversion
  635.                  * ("e", "s", etc.), width, and precision. */
  636.     int intValue;        /* Used to hold value to pass to sprintf, if
  637.                  * it's a one-word integer or char value */
  638.     char *ptrValue = NULL;    /* Used to hold value to pass to sprintf, if
  639.                  * it's a one-word value. */
  640.     double doubleValue;        /* Used to hold value to pass to sprintf if
  641.                  * it's a double value. */
  642.     int whichValue;        /* Indicates which of intValue, ptrValue,
  643.                  * or doubleValue has the value to pass to
  644.                  * sprintf, according to the following
  645.                  * definitions: */
  646. #   define INT_VALUE 0
  647. #   define PTR_VALUE 1
  648. #   define DOUBLE_VALUE 2
  649.     char *dst = interp->result;    /* Where result is stored.  Starts off at
  650.                  * interp->resultSpace, but may get dynamically
  651.                  * re-allocated if this isn't enough. */
  652.     int dstSize = 0;        /* Number of non-null characters currently
  653.                  * stored at dst. */
  654.     int dstSpace = TCL_RESULT_SIZE;
  655.                 /* Total amount of storage space available
  656.                  * in dst (not including null terminator. */
  657.     int noPercent;        /* Special case for speed:  indicates there's
  658.                  * no field specifier, just a string to copy. */
  659.     int argIndex;        /* Index of argument to substitute next. */
  660.     int gotXpg = 0;        /* Non-zero means that an XPG3 %n$-style
  661.                  * specifier has been seen. */
  662.     int gotSequential = 0;    /* Non-zero means that a regular sequential
  663.                  * (non-XPG3) conversion specifier has been
  664.                  * seen. */
  665.     int useShort;        /* Value to be printed is short (half word). */
  666.     char *end;            /* Used to locate end of numerical fields. */
  667.  
  668.     /*
  669.      * This procedure is a bit nasty.  The goal is to use sprintf to
  670.      * do most of the dirty work.  There are several problems:
  671.      * 1. this procedure can't trust its arguments.
  672.      * 2. we must be able to provide a large enough result area to hold
  673.      *    whatever's generated.  This is hard to estimate.
  674.      * 2. there's no way to move the arguments from argv to the call
  675.      *    to sprintf in a reasonable way.  This is particularly nasty
  676.      *    because some of the arguments may be two-word values (doubles).
  677.      * So, what happens here is to scan the format string one % group
  678.      * at a time, making many individual calls to sprintf.
  679.      */
  680.  
  681.     if (argc < 2) {
  682.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  683.         " formatString ?arg arg ...?\"", (char *) NULL);
  684.     return TCL_ERROR;
  685.     }
  686.     argIndex = 2;
  687.     for (format = argv[1]; *format != 0; ) {
  688.     register char *newPtr = newFormat;
  689.  
  690.     width = precision = noPercent = useShort = 0;
  691.     whichValue = PTR_VALUE;
  692.  
  693.     /*
  694.      * Get rid of any characters before the next field specifier.
  695.      */
  696.  
  697.     if (*format != '%') {
  698.         register char *p;
  699.  
  700.         ptrValue = p = format;
  701.         while ((*format != '%') && (*format != 0)) {
  702.         *p = *format;
  703.         p++;
  704.         format++;
  705.         }
  706.         size = p - ptrValue;
  707.         noPercent = 1;
  708.         goto doField;
  709.     }
  710.  
  711.     if (format[1] == '%') {
  712.         ptrValue = format;
  713.         size = 1;
  714.         noPercent = 1;
  715.         format += 2;
  716.         goto doField;
  717.     }
  718.  
  719.     /*
  720.      * Parse off a field specifier, compute how many characters
  721.      * will be needed to store the result, and substitute for
  722.      * "*" size specifiers.
  723.      */
  724.  
  725.     *newPtr = '%';
  726.     newPtr++;
  727.     format++;
  728.     if (isdigit(UCHAR(*format))) {
  729.         int tmp;
  730.  
  731.         /*
  732.          * Check for an XPG3-style %n$ specification.  Note: there
  733.          * must not be a mixture of XPG3 specs and non-XPG3 specs
  734.          * in the same format string.
  735.          */
  736.  
  737.         tmp = strtoul(format, &end, 10);
  738.         if (*end != '$') {
  739.         goto notXpg;
  740.         }
  741.         format = end+1;
  742.         gotXpg = 1;
  743.         if (gotSequential) {
  744.         goto mixedXPG;
  745.         }
  746.         argIndex = tmp+1;
  747.         if ((argIndex < 2) || (argIndex >= argc)) {
  748.         goto badIndex;
  749.         }
  750.         goto xpgCheckDone;
  751.     }
  752.  
  753.     notXpg:
  754.     gotSequential = 1;
  755.     if (gotXpg) {
  756.         goto mixedXPG;
  757.     }
  758.  
  759.     xpgCheckDone:
  760.     while ((*format == '-') || (*format == '#') || (*format == '0')
  761.         || (*format == ' ') || (*format == '+')) {
  762.         *newPtr = *format;
  763.         newPtr++;
  764.         format++;
  765.     }
  766.     if (isdigit(UCHAR(*format))) {
  767.         width = strtoul(format, &end, 10);
  768.         format = end;
  769.     } else if (*format == '*') {
  770.         if (argIndex >= argc) {
  771.         goto badIndex;
  772.         }
  773.         if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) {
  774.         goto fmtError;
  775.         }
  776.         argIndex++;
  777.         format++;
  778.     }
  779.     if (width != 0) {
  780.         sprintf(newPtr, "%d", width);
  781.         while (*newPtr != 0) {
  782.         newPtr++;
  783.         }
  784.     }
  785.     if (*format == '.') {
  786.         *newPtr = '.';
  787.         newPtr++;
  788.         format++;
  789.     }
  790.     if (isdigit(UCHAR(*format))) {
  791.         precision = strtoul(format, &end, 10);
  792.         format = end;
  793.     } else if (*format == '*') {
  794.         if (argIndex >= argc) {
  795.         goto badIndex;
  796.         }
  797.         if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) {
  798.         goto fmtError;
  799.         }
  800.         argIndex++;
  801.         format++;
  802.     }
  803.     if (precision != 0) {
  804.         sprintf(newPtr, "%d", precision);
  805.         while (*newPtr != 0) {
  806.         newPtr++;
  807.         }
  808.     }
  809.     if (*format == 'l') {
  810.         format++;
  811.     } else if (*format == 'h') {
  812.         useShort = 1;
  813.         *newPtr = 'h';
  814.         newPtr++;
  815.         format++;
  816.     }
  817.     *newPtr = *format;
  818.     newPtr++;
  819.     *newPtr = 0;
  820.     if (argIndex >= argc) {
  821.         goto badIndex;
  822.     }
  823.     switch (*format) {
  824.         case 'i':
  825.         newPtr[-1] = 'd';
  826.         case 'd':
  827.         case 'o':
  828.         case 'u':
  829.         case 'x':
  830.         case 'X':
  831.         if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue)
  832.             != TCL_OK) {
  833.             goto fmtError;
  834.         }
  835.         whichValue = INT_VALUE;
  836.         size = 40 + precision;
  837.         break;
  838.         case 's':
  839.         ptrValue = argv[argIndex];
  840.         size = strlen(argv[argIndex]);
  841.         break;
  842.         case 'c':
  843.         if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue)
  844.             != TCL_OK) {
  845.             goto fmtError;
  846.         }
  847.         whichValue = INT_VALUE;
  848.         size = 1;
  849.         break;
  850.         case 'e':
  851.         case 'E':
  852.         case 'f':
  853.         case 'g':
  854.         case 'G':
  855.         if (Tcl_GetDouble(interp, argv[argIndex], &doubleValue)
  856.             != TCL_OK) {
  857.             goto fmtError;
  858.         }
  859.         whichValue = DOUBLE_VALUE;
  860.         size = 320;
  861.         if (precision > 10) {
  862.             size += precision;
  863.         }
  864.         break;
  865.         case 0:
  866.         interp->result =
  867.             "format string ended in middle of field specifier";
  868.         goto fmtError;
  869.         default:
  870.         sprintf(interp->result, "bad field specifier \"%c\"", *format);
  871.         goto fmtError;
  872.     }
  873.     argIndex++;
  874.     format++;
  875.  
  876.     /*
  877.      * Make sure that there's enough space to hold the formatted
  878.      * result, then format it.
  879.      */
  880.  
  881.     doField:
  882.     if (width > size) {
  883.         size = width;
  884.     }
  885.     if ((dstSize + size) > dstSpace) {
  886.         char *newDst;
  887.         int newSpace;
  888.  
  889.         newSpace = 2*(dstSize + size);
  890.         newDst = (char *) ckalloc((unsigned) newSpace+1);
  891.         if (dstSize != 0) {
  892.         memcpy((VOID *) newDst, (VOID *) dst, (size_t) dstSize);
  893.         }
  894.         if (dstSpace != TCL_RESULT_SIZE) {
  895.         ckfree(dst);
  896.         }
  897.         dst = newDst;
  898.         dstSpace = newSpace;
  899.     }
  900.     if (noPercent) {
  901.         memcpy((VOID *) (dst+dstSize), (VOID *) ptrValue, (size_t) size);
  902.         dstSize += size;
  903.         dst[dstSize] = 0;
  904.     } else {
  905.         if (whichValue == DOUBLE_VALUE) {
  906.         sprintf(dst+dstSize, newFormat, doubleValue);
  907.         } else if (whichValue == INT_VALUE) {
  908.         if (useShort) {
  909.             sprintf(dst+dstSize, newFormat, (short) intValue);
  910.         } else {
  911.             sprintf(dst+dstSize, newFormat, intValue);
  912.         }
  913.         } else {
  914.         sprintf(dst+dstSize, newFormat, ptrValue);
  915.         }
  916.         dstSize += strlen(dst+dstSize);
  917.     }
  918.     }
  919.  
  920.     interp->result = dst;
  921.     if (dstSpace != TCL_RESULT_SIZE) {
  922.     interp->freeProc = (Tcl_FreeProc *) free;
  923.     } else {
  924.     interp->freeProc = 0;
  925.     }
  926.     return TCL_OK;
  927.  
  928.     mixedXPG:
  929.     interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers";
  930.     goto fmtError;
  931.  
  932.     badIndex:
  933.     if (gotXpg) {
  934.     interp->result = "\"%n$\" argument index out of range";
  935.     } else {
  936.     interp->result = "not enough arguments for all format specifiers";
  937.     }
  938.  
  939.     fmtError:
  940.     if (dstSpace != TCL_RESULT_SIZE) {
  941.     ckfree(dst);
  942.     }
  943.     return TCL_ERROR;
  944. }
  945.